File:of Disk: Disks/MyPDP/m8-rka0-rkb0
(Source file text)
C PGM TIMAFI CP-NAEHERUNG : TFIT03.FT C FIT FUER DATEN AUS MESSUNG DER SPEZ. WAERME UM THERMOMETER ZU EICHEN C T=1/(S(3)+S(4)*......S(6)*LN(R)**3) DIMENSION R1(25),R2(25),Q(25),S(6),DN(6) DIMENSION A(25,6),B(25),X(6),AUX(12),IPIV(6) DIMENSION FMATR(6,6),BETA(6) INTEGER FRAGE LOGICAL NEW LPT=3 ITERM=4 IPARO=5 IPARN=6 COM. DATENEINGABE WRITE(ITERM,1000) READ(ITERM,2000) NEW IF(NEW) GOTO 200 READ(IPARO,3000) NP DO 100 I=1,NP READ(IPARO,3001) R1(I),R2(I),Q(I) 100 CONTINUE GOTO 500 200 REWIND IPARN WRITE(ITERM,1001) READ(ITERM,2001) NP WRITE(IPARN,3000) NP DO 300 I=1,NP WRITE(ITERM,1002) I READ(ITERM,2002) R1(I) WRITE(ITERM,1003) I READ(ITERM,2002) R2(I) WRITE(ITERM,1004) I READ(ITERM,2002) Q(I) WRITE(IPARN,3001) R1(I),R2(I),Q(I) 300 CONTINUE 500 CONTINUE WRITE(ITERM,1005) WRITE(LPT,1005) DO 400 I=1,NP WRITE(ITERM,2003) I,R1(I),R2(I),Q(I) WRITE(LPT,2003) I,R1(I),R2(I),Q(I) 400 CONTINUE NUMIT=1 DO 600 I=1,NP 600 CONTINUE COM. NAEHERUNGSWERTE S(1)=-0.25 S(2)=0.104 S(3)=-0.06286 S(4)=0.002248 S(5)=0.003892 S(6)=0.0000001 WRITE(ITERM,1006) DO 900 I=1,6 WRITE(ITERM,1007) I,S(I) 900 CONTINUE COM. BERECHNUNG DER TAYLORKOEFFIZIENTEN WRITE(ITERM,1008) NUMIT DO 700 I=1,NP ALN1=ALOG(R1(I)) ALN2=ALOG(R2(I)) T1=1./(S(3)+S(4)*ALN1+S(5)*ALN1**2+S(6)*ALN1**3) T2=1./(S(3)+S(4)*ALN2+S(5)*ALN2**2+S(6)*ALN2**3) WRITE(ITERM,1009) T1,T2 B(I)=1.0-S(1)/(2.0*Q(I))*(T2**2-T1**2)- $ S(2)/(4.0*Q(I))*(T2**4-T1**4) A(I,1)=0.5/Q(I)*(T2**2-T1**2) A(I,2)=0.25/Q(I)*(T2**4-T1**4) A(I,3)=-S(1)/Q(I)*(T2**3-T1**3)- $ S(2)/Q(I)*(T2**5-T1**5) A(I,4)=-S(1)/Q(I)*(T2**3*ALN2-T1**3*ALN1)- $ S(2)/Q(I)*(T2**5*ALN2-T1**5*ALN1) A(I,5)=-S(1)/Q(I)*(T2**3*ALN2**2-T1**3*ALN1**2)- $ S(2)/Q(I)*(T2**5*ALN2**2-T1**5*ALN1**2) A(I,6)=-S(1)/Q(I)*(T2**3*ALN2**3-T1**3*ALN1**3)- $ S(2)/Q(I)*(T2**5*ALN2**3-T1**5*ALN1**3) WRITE(ITERM,2004) A(I,1),A(I,2),A(I,3),B(I) WRITE(ITERM,2007) A(I,4),A(I,5),A(I,6),Q(I) 700 CONTINUE COM BERECHNUNG DER FEHLERMATRIX DO 10 K=1,6 DO 20 J=1,6 FMATR(J,K)=0.0 DO 30 I=1,NP FMATR(J,K)=FMATR(J,K)+A(I,J)*A(I,K) 30 CONTINUE 20 CONTINUE 10 CONTINUE DO 40 K=1,6 BETA(K)=0.0 DO 50 I=1,NP BETA(K)=BETA(K)+B(I)*A(I,K) 50 CONTINUE 40 CONTINUE GOTO 60 COM. AUSDRUCK FEHLERMATRIX TERMINAL DO 60 K=1,6 WRITE(ITERM,2006) FMATR(K,1),FMATR(K,2),FMATR(K,3),FMATR(K,4) WRITE(ITERM,2008) FMATR(K,5),FMATR(K,6),BETA(K) 60 CONTINUE COM BERECHNUNG UNTERE DREIECKSMATRIX DO 110 K=3,5 KK=K+1 DO 120 I=KK,6 FAK=FMATR(I,K)/FMATR(K,K) BETA(I)=BETA(I)-FAK*BETA(K) DO 130 J=K,6 FMATR(I,J)=FMATR(I,J)-FAK*FMATR(K,J) 130 CONTINUE 120 CONTINUE 110 CONTINUE COM BERECHNUNG OBERE DREIECKSMATRIX FAK=FMATR(2,1)/FMATR(1,1) BETA(2)=BETA(2)-FAK*BETA(1) FMATR(2,1)=0.0 FMATR(2,2)=FMATR(2,2)-FAK*FMATR(1,2) GOTO 70 COM. AUSDRUCK DREIECKSMATRIX TERMINAL DO 70 K=1,6 WRITE(ITERM,2006) FMATR(K,1),FMATR(K,2),FMATR(K,3),FMATR(K,4) WRITE(ITERM,2008) FMATR(K,5),FMATR(K,6),BETA(K) 70 CONTINUE COM BERECHNUNG DER KORREKTUREN X(I) DO 140 I=1,4 II=7-I SUM=0.0 X(II)=0.0 DO 150 J=II,6 SUM=SUM+FMATR(II,J)*X(J) 150 CONTINUE X(II)=(BETA(II)-SUM)/FMATR(II,II) 140 CONTINUE X(2)=BETA(2)/FMATR(2,2) X(1)=(BETA(1)-FMATR(1,2)*X(2))/FMATR(1,1) WRITE(ITERM,2009) IF (NUMIT.EQ.IFIX(NUMIT/2)*2) GOTO 160 S(3)=S(3)+X(3) S(4)=S(4)+X(4) S(5)=S(5)+X(5) S(6)=S(6)+X(6) 160 CONTINUE IF (NUMIT.NE.IFIX(NUMIT/2)*2) GOTO 170 S(1)=S(1)+X(1) S(2)=S(2)+X(2) 170 CONTINUE DO 800 I=1,6 DN(I)=100.0*X(I)/S(I) WRITE(ITERM,2005) I,S(I),X(I),DN(I) 800 CONTINUE SIGMA=0.0 DO 850 I=1,NP SIGMA=SIGMA+B(I)*B(I) 850 CONTINUE SIGMA=SQRT(SIGMA/NP) WRITE(ITERM,1013) SIGMA NUMIT=NUMIT+1 WRITE(ITERM,1012) READ(ITERM,2000) NEW IF (NEW) GOTO 900 WRITE(LPT,1011) DO 990 I=1,6 WRITE(LPT,2011) I,S(I),DN(I) 990 CONTINUE WRITE(LPT,1013) SIGMA DO 995 I=1,NP ALN1=ALOG(R1(I)) ALN2=ALOG(R2(I)) T1=1./(S(3)+S(4)*ALN1+S(5)*ALN1**2+S(6)*ALN1**3) T2=1./(S(3)+S(4)*ALN2+S(5)*ALN2**2+S(6)*ALN2**3) WRITE(LPT,1014) I,T1,T2,B(I) TMIT=(T1+T2)/2.0 CP=Q(I)/(T2-T1) WRITE(LPT,1015) TMIT,CP 995 CONTINUE 1000 FORMAT (1X,'NEW DATA SET (T/F)?',T30,$) 1001 FORMAT (1X,'NUMBER OF DATAPOINTS NP =',T30,$) 1002 FORMAT (/T5,'R1(',I2,') =',T15,$) 1003 FORMAT (T5,'R2(',I2,') =',T15,$) 1004 FORMAT (T5,'Q (',I2,') =',T15,$) 1005 FORMAT (1H0,'MEASURED VALUES USED FOR FIT:'/ $ 1X,29('-')//T10,'I',T25,'R1(I)',T45,'R2(I)',T66,'Q(I)'/) 1006 FORMAT (///,1X'APPROXIMATION VALUES:'/) 1007 FORMAT (1X,'X(',I1,')=',F20.8) 1008 FORMAT (///,1X,'NUMBER OF ITERATION: ',I2,//) 1009 FORMAT (//,1X,'T1=',F10.4,' T2=',F10.4,/) 1011 FORMAT (///,1X'CALCULATED VALUES AND ERRORS IN PERCENT',/) 1012 FORMAT (//,1X,'FIT WITH NEW PARAMETERS (T/F)?',T50,$) 1013 FORMAT (//,1X,'MEAN ERROR OF DATAPOINTS =',F10.3) 1014 FORMAT (/,1X,I3' T1=',F10.4,' T2=',F10.4,/ $ ' ERROR =',F10.3) 1015 FORMAT (/,' T := ',F10.4,' CP := ',F12.6) 2000 FORMAT (L1) 2001 FORMAT (I3) 2002 FORMAT (F20.3) 2003 FORMAT (1X,I9,3F20.3) 2004 FORMAT (1X,4E16.4) 2005 FORMAT (1X,I9,3G20.8) 2006 FORMAT (//,1X,4E16.4) 2007 FORMAT (1X,3E16.4,' ',F20.3) 2008 FORMAT (1X,2E16.4,' ',E16.4) 2009 FORMAT (//,1X) 2010 FORMAT (1X,I3,G16.8) 2011 FORMAT (1X,I3,G16.8,F8.2) 2012 FORMAT (F20.5) 3000 FORMAT (I3) 3001 FORMAT (3F20.3) 6001 FORMAT (' ',6G16.8,' ',G16.8) 111 CONTINUE END